home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus Leser 19 / Amiga Plus Leser CD 19.iso / Online / anubis-3.6.0 / contrib / msg2smtp.pl next >
Perl Script  |  2002-11-17  |  7KB  |  232 lines
  1. #!/usr/bin/perl
  2.  
  3. # $Id: msg2smtp.pl,v 1.4 2002/10/29 11:34:07 polak Exp $
  4.  
  5. my $usage = qq!
  6. $0 takes a mail message on STDIN and relays it to an SMTP server.
  7.  
  8. $0 -h HOST [options]
  9.   -h HOST        (hostname of SMTP server, often 'localhost')
  10.  
  11.   Options:
  12.  
  13.   -p PORT        (port of the SMTP server)
  14.   -e HELO_DOMAIN (domain we use when to say helo to smtp server)
  15.   -U USERNAME    (ESMTP auth username)
  16.   -P PASSWORD    (ESMTP auth password)
  17.   -m MECHANISM   (ESMTP auth mechanism - default is PLAIN)
  18.   -d             (shows SMTP conversation and perl debugging)
  19.     !;
  20.  
  21. #------------------------------------------
  22. # INDEX
  23.  
  24. # 0. GPL License
  25. # 1. Module Dependencies
  26. # 2. Set options by Command-line Arguments
  27. # 3. Read Message by STDIN
  28. # 4. Extend Net::SMTP to allow us to choose an auth mechanism
  29. # 5. Send message via SMTP
  30.  
  31. #------------------------------------------
  32. # 0. GPL License
  33. #
  34. #  This file is a part of GNU Anubis.
  35. #  Copyright (C) 2001, 2002 The Anubis Team.
  36. # 
  37. #  GNU Anubis is free software; you can redistribute it and/or modify
  38. #  it under the terms of the GNU General Public License as published by
  39. #  the Free Software Foundation; either version 2 of the License, or
  40. #  (at your option) any later version.
  41. # 
  42. #  GNU Anubis is distributed in the hope that it will be useful,
  43. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  44. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  45. #  GNU General Public License for more details.
  46. # 
  47. #  You should have received a copy of the GNU General Public License
  48. #  along with GNU Anubis; if not, write to the Free Software
  49. #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  50. # 
  51. #  GNU Anubis is released under the GPL with the additional exemption that
  52. #  compiling, linking, and/or using OpenSSL is allowed.
  53. # 
  54. #  msg2smtp.pl code: Michael de Beer <michael@debeer.org>
  55. #    ext_auth() mainly taken from the Net::SMTP module
  56. #------------------------------------------
  57. # 1. Module Dependencies
  58.  
  59. use warnings;  use strict;
  60. use Getopt::Std;
  61. use vars qw!$opt_h $opt_p $opt_e $opt_U $opt_P $opt_d $opt_m!;
  62.  
  63. # REQUIRED MODULES:
  64. use Mail::Address;
  65. use Net::SMTP;
  66. # perl -MCPAN -e 'install Mail::Address'
  67. # perl -MCPAN -e 'install Net::SMTP'
  68.  
  69. # OPTIONAL MODULES: Authen:SASL (for ESMTP auth)
  70. # perl -MCPAN -e 'install Authen::SASL'
  71.  
  72. # Note: this script originally used functions from Mail::Box to:
  73. # * parse messages and
  74. # * interface with Net::SMTP
  75. # However, I discovered Mail::Box did not support these options:
  76. #   'port username password'
  77. # So, I am not using Mail::Box.
  78. # # use Mail::Box; use Mail::Transport::SMTP;
  79.  
  80. #------------------------------------------
  81. # 2. Set options by Command-line Arguments
  82.  
  83. getopts('dh:p:e:U:P:m:');
  84.  
  85. my (%smtp_options, $host, $username, $password, $auth_mech);
  86.  
  87. if ($opt_h) { 
  88.     $host = $opt_h;
  89. } else {
  90.     print $usage, "\n";
  91.     exit(255);
  92. } 
  93.  
  94. $smtp_options{Port} = $opt_p if ($opt_p);
  95. $smtp_options{Hello} = $opt_e if ($opt_e);
  96. $smtp_options{Debug} = 1 if ($opt_d);
  97. $username = $opt_U if ($opt_U);
  98. $password = $opt_P if ($opt_P);
  99. $auth_mech = $opt_m ? $opt_m : 'PLAIN'; # not tested other AUTH mechanisms
  100.  
  101. #------------------------------------------
  102. # 3. Read Message by STDIN
  103.  
  104. # read the message and parse the headers for RCPT and FROM
  105. my ($from, @rcpt);
  106. my ($txt_head) = '';
  107. my ($txt_body) = '';
  108. # the only trick thing are To: lines that are folded
  109. # I deal with that with 4 Rules, below.
  110.  
  111. my ($tmp, $chunk, @to_addresses);
  112.  
  113. HEAD: while ($tmp = <>){
  114.  
  115. # Rule 1: If it is a folded line, add line to $chunk, skip to next line
  116.   if ($tmp =~ /^\s+\S+/) { $chunk .= $tmp; next HEAD  };
  117.  
  118. # Rule 2: If it is not a folded line, process old chunk
  119.   $_ = $chunk ? $chunk : '';
  120.   if (/^From:/i) { 
  121.       my @from_addresses;
  122.       @from_addresses = Mail::Address->parse($_);
  123.       $from = pop(@from_addresses)->address;
  124.       die "From: address invalid" unless $from;
  125.       die "there is more than one From: address" if @from_addresses;
  126.   } elsif (/^(To|CC|BCC):/i) {
  127.       @to_addresses = (); # re-initialize because we re-enter this loop
  128.       @to_addresses = Mail::Address->parse($_);
  129.       foreach my $obj (@to_addresses) {
  130.       push @rcpt, $obj->address;
  131.       }
  132.   }
  133.   $txt_head .= $chunk if ($chunk);
  134.  
  135. # Rule 3: If the line is a blank line, exit HEAD section
  136.   last HEAD if $tmp =~ /^$/;
  137.  
  138. # Rule 4: start a new chunk
  139.   $chunk = $tmp;
  140. }
  141.  
  142. while (<>){
  143.    $txt_body .= $_;
  144. }
  145.  
  146. #if ($smtp_options{Debug}){print "FROM $from\n"; map {print "TO $_\n"} @rcpt;}
  147.  
  148. #------------------------------------------
  149. # 4. Extend Net::SMTP to allow us to choose and auth mechanism
  150.  
  151. # We make an extend-auth method, as Net::SMTP::auth() 
  152. # does not seem to accurately pick a mechanism
  153.  
  154. package Net::SMTP;
  155. sub ext_auth { # taken from Net::SMTP, only modify $mechanisms
  156.     my ($self, $username, $password, $mechanisms) = @_;
  157.  
  158.     require MIME::Base64;
  159.     require Authen::SASL;
  160.  
  161.     my $m = $self->supports('AUTH',500,["Command unknown: 'AUTH'"]);
  162.     return unless defined $m;
  163.     my $sasl;
  164.  
  165.     if (ref($username) and UNIVERSAL::isa($username,'Authen::SASL')) {
  166.       $sasl = $username;
  167.       $sasl->mechanism($mechanisms);
  168.     }
  169.     else {
  170.       die "auth(username, password)" if not length $username;
  171.       $sasl = Authen::SASL->new(mechanism=> $mechanisms,
  172.                 callback => { user => $username,
  173.                                               pass => $password,
  174.                           authname => $username,
  175.                                             });
  176.     }
  177.     my $client = $sasl->client_new('smtp',${*$self}{'net_smtp_host'},0);
  178.     my $str    = $client->client_start;
  179.  
  180.     # We dont support sasl mechanisms that encrypt the socket traffic.
  181.     # todo that we would really need to change the ISA hierarchy
  182.     # so we dont inherit from IO::Socket, but instead hold it in an attribute
  183.  
  184.     my @cmd = ("AUTH", $client->mechanism, MIME::Base64::encode_base64($str,''));
  185.     my $code;
  186.  
  187.     while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
  188.       @cmd = (MIME::Base64::encode_base64(
  189.     $client->client_step(
  190.       MIME::Base64::decode_base64(
  191.         ($self->message)[0]
  192.       )
  193.     ), ''
  194.       ));
  195.     }
  196.  
  197.     $code == CMD_OK;
  198. }
  199.  
  200. #------------------------------------------
  201. # 5. Send message via SMTP
  202.  
  203. package main;
  204.  
  205. my $smtp = Net::SMTP->new($host, %smtp_options);
  206. $smtp or die "failed to connect to SMTP server";
  207.  
  208. if ($username) { 
  209.   print "WARNING: failed ESMTP auth using username '$username'...trying to send anyway\n" unless $smtp->ext_auth ($username, $password, $auth_mech);
  210. };
  211. $smtp->mail($from) or die "server rejected FROM address '$from'";
  212. $smtp->to(@rcpt, {SkipBad => 1}) or die "server rejected all TO addresses";
  213. $smtp->data() or die "server crashed while preparing to send DATA";
  214. $smtp->datasend($txt_head) or die "server crashed while sending DATA.1";
  215. $smtp->datasend("\n") or die "server crashed while sending DATA.2";
  216. $smtp->datasend($txt_body) or die "server crashed while sending DATA.3";
  217. $smtp->dataend() or die "server crashed while ending DATA";
  218. $smtp->quit or die "server crashed while quiting - message may not be lost";;
  219.  
  220. __END__
  221.  
  222. # $Log: msg2smtp.pl,v $
  223. # Revision 1.4  2002/10/29 11:34:07  polak
  224. # updated to GNU. Now it's GNU Anubis!
  225. #
  226. # Revision 1.3  2002/10/06 11:37:05  madebeer
  227. # added -m MECHANISM option for ESTMP auth
  228. #
  229. # Revision 1.2  2002/10/06 11:33:13  madebeer
  230. # added logging
  231. #
  232.